;;;; nehe-support.lisp
;;;;
;;;; Utilities and other useful stuff for doing OpenGL in CCL.
;;;;

(in-package :nehe)


;;;
;;; OpenGL View and (really naive) Animation
;;;

(defclass gl-renderer-controller (ns:ns-object)
  ((gl-view :accessor gl-view :initarg :gl-view :initform nil))
  (:metaclass ns:+ns-object))

(objc:defmethod (#/windowWillClose: :void) ((controller gl-renderer-controller) notification)
  (declare (ignore notification))
  (when (and (slot-boundp controller 'gl-view)
             (gl-view controller))
    (scene-cleanup (gl-view controller))
    (stop-animation (gl-view controller))))

(defclass basic-gl-renderer (ns:ns-opengl-view)
  ((gl-version :reader gl-version)
   (extensions :reader gl-extensions)
   (vendor :reader gl-vendor)
   (renderer :reader gl-renderer)
   (animate-p :accessor animate-p :initform nil :initarg :animate-p)
   (current-time :accessor current-time :initform (#_CFAbsoluteTimeGetCurrent))
   (timer :accessor timer :initarg :timer :initform nil))
  (:metaclass ns:+ns-object))

(defgeneric init (canvas-view)
  (:documentation "Chance to initialize OpenGL context"))

(defgeneric draw-scene (canvas-view)
  (:documentation "Draw the scene."))

(defgeneric scene-cleanup (canvas-view)
  (:documentation "Called when window view is kept in is about to close."))

(objc:defmethod (#/drawRect: :void) ((self basic-gl-renderer) (rect :<NSR>ect))
  (clear-background self)
  (draw-scene self)
  (#_glFlush))

(defmethod scene-cleanup ((view basic-gl-renderer))
  nil)

(defmethod animation-timer ((view basic-gl-renderer))
  (when view
    (with-slots (timer current-time) view
      (loop
        (with-macptrs ((context (#/openGLContext view))
                       (bounds (#/bounds view)))
          (when context
            (#/makeCurrentContext context)
            (#/drawRect: view bounds)
            (#/flushBuffer context)))
        (#/clearCurrentContext ns:ns-opengl-context)
        ;(process-interrupt timer #'animation-timer view)
        (sleep (/ 1.0 60.0))))))

(defmethod start-animation ((view basic-gl-renderer))
  (when (not (timer view))
    (let ((proc (make-process "BASIC-GL-RENDERER TIMER")))
      (process-preset proc #'animation-timer view)
      (setf (timer view) proc)
      (process-enable proc))))

(defmethod stop-animation ((view basic-gl-renderer))
  (when (timer view)
    (process-reset (timer view))
    (setf (timer view) nil)))

(objc:defmethod (#/prepareOpenGL :void) ((gl-view basic-gl-renderer))
  (init gl-view)
  (#/reshape gl-view))

(objc:defmethod (#/reshape :void) ((gl-view basic-gl-renderer))
  (let* ((frame (#/frame gl-view))
         (width (ns:ns-rect-width frame))
         (height (ns:ns-rect-height frame)))
    (#_glViewport 0 0 (truncate width) (truncate height))
    (with-matrix-mode #$GL_PROJECTION
      (#_glLoadIdentity)
      (#_gluPerspective 45.0d0 (/ width height) 0.1d0 100.0d0))
    (#_glLoadIdentity)))

(defun open-renderer (renderer-class &optional (width 800) (height 600))
  (ccl::with-autorelease-pool
      (let* ((rect (ns:make-ns-rect 0 0 width height))
             (w (make-instance 'ns:ns-window
                  :with-content-rect rect
                  :style-mask (logior #$NSTitledWindowMask
                                      #$NSClosableWindowMask
                                      #$NSMiniaturizableWindowMask)
                  :backing #$NSBackingStoreBuffered
                  :defer t))
             (renderer (make-instance renderer-class
                         :animate-p t))
             (controller (make-instance 'gl-renderer-controller
                           :gl-view renderer)))
        (#/setTitle: w (ccl::%make-nsstring (format nil "Simple OpenGL Canvas - ~A" (class-name (class-of renderer)))))
        (#/setContentView: w renderer)
        (#/setDelegate: w controller)
        (#/center w)
        (#/orderFront: w nil)
        (#/contentView w))))

(defmethod determine-capabilities ((canvas basic-gl-renderer))
  "Check for and enable various OpenGL extensions."
  (with-slots (gl-version vendor renderer extensions) canvas
    (setf gl-version (%get-cstring (#_glGetString #$GL_VERSION)))
    (setf extensions (cl-ppcre:split "\\s+" (%get-cstring (#_glGetString #$GL_EXTENSIONS))))
    (setf vendor (%get-cstring (#_glGetString #$GL_VENDOR)))
    (setf renderer (%get-cstring (#_glGetString #$GL_RENDERER)))))

(defmethod init ((canvas basic-gl-renderer))
  (determine-capabilities canvas)
  (#_glShadeModel #$GL_SMOOTH)
  (#_glClearColor 0.0 0.0 0.0 0.5)
  (#_glClearDepth 1.0d0)
  (#_glHint #$GL_PERSPECTIVE_CORRECTION_HINT #$GL_NICEST))
  
(defmethod clear-background ((self basic-gl-renderer))
  (#_glClear #.(logior #$GL_COLOR_BUFFER_BIT #$GL_DEPTH_BUFFER_BIT)))

(defmethod draw-scene ((canvas basic-gl-renderer))
  ;(#_glLoadIdentity)
  ;(#_glTranslatef -1.0 0.0 1.0)
  (with-gl #$GL_POLYGON
    (#_glColor3f 1.0 0.0 0.0)
    (#_glVertex3f 0.0 1.0 0.0) 
    (#_glColor3f 0.0 1.0 0.0)
    (#_glVertex3f -1.0 -1.0 0.0) 
    (#_glColor3f 0.0 0.0 1.0)
    (#_glVertex3f 1.0 -1.0 0.0)))

;;; Textures

(defstruct gltexture
  name
  width
  height)

(defclass texture ()
  ((source :reader source :initarg :source :initform nil)
   (glview :reader glview :initarg :glview :initform nil)
   (binding :accessor binding :initarg :binding :initform 0)
   (width :accessor width :initarg :width :initform 0.0)
   (height :accessor height :initarg :height :initform 0.0)
   (mag-filter :accessor mag-filter :initarg :mag-filter :initform #$GL_LINEAR)
   (min-filter :accessor min-filter :initarg :min-filter :initform #$GL_LINEAR)))

(defun cf-url-create-with-string (string)
  (#_CFURLCreateWithString #&kCFAllocatorDefault 
                           (ccl::%make-nsstring string)
                           (%null-ptr)))

(defun make-gltexture-from-url-string (url &optional (tex-name 0))
  ;;; Copied verbatim from Apple's OpenGL Programming Guide
  (let* ((source (#_CGImageSourceCreateWithURL (cf-url-create-with-string url) (%null-ptr)))
         (image (#_CGImageSourceCreateImageAtIndex source 0 (%null-ptr)))
         (width (#_CGImageGetWidth image))
         (height (#_CGImageGetHeight image))
         (rect (ns:make-ns-rect 0 0 width height))
         (data (#_calloc (* width 4) height))
         (space (#_CGColorSpaceCreateDeviceRGB))
         (bitmap-context (#_CGBitmapContextCreate data width height 8 (* width 4)
                                                  space
                                                  #.(logior #$kCGBitmapByteOrder32Host
                                                            #$kCGImageAlphaPremultipliedFirst))))
    (#_CGContextDrawImage bitmap-context rect image)
    (#_CGContextRelease bitmap-context)
    (#_glPixelStorei #$GL_UNPACK_ROW_LENGTH width)
    (#_glPixelStorei #$GL_UNPACK_ALIGNMENT 1)
    (when (= tex-name 0)
      (rlet ((uid :<GL>uint))
        (#_glGenTextures 1 uid)
        (setf tex-name (%get-unsigned-word uid))))
    (#_glBindTexture #$GL_TEXTURE_RECTANGLE_ARB tex-name)
    ;(#_glBindTexture #$GL_TEXTURE_RECTANGLE_ARB #$GL_TEXTURE_STORAGE_HINT_APPLE #$GL_STORAGE_SHARED_APPLE)
    (#_glTexParameteri #$GL_TEXTURE_RECTANGLE_ARB #$GL_TEXTURE_MIN_FILTER #$GL_LINEAR)
    (#_glTexImage2D #$GL_TEXTURE_RECTANGLE_ARB 0 #$GL_RGBA8 width height
                    0 #$GL_BGRA_EXT #$GL_UNSIGNED_INT_8_8_8_8_REV data)
    (#_free data)
    (make-gltexture :name tex-name :width (coerce width 'float) :height (coerce height 'float))))

(defun %gl-texture-image-from-source (source mag-filter min-filter &optional (tex-name 0))
  ;;; Copied verbatim from Apple's OpenGL Programming Guide
  (let* ((source (#_CGImageSourceCreateWithURL (cf-url-create-with-string source) (%null-ptr)))
         (image (#_CGImageSourceCreateImageAtIndex source 0 (%null-ptr)))
         (width (#_CGImageGetWidth image))
         (height (#_CGImageGetHeight image))
         (rect (ns:make-ns-rect 0 0 width height))
         (data (#_calloc (* width 4) height))
         (space (#_CGColorSpaceCreateDeviceRGB))
         (bitmap-context (#_CGBitmapContextCreate data width height 8 (* width 4)
                                                  space
                                                  #.(logior #$kCGBitmapByteOrder32Host
                                                            #$kCGImageAlphaPremultipliedFirst))))
    (if (or (null source)
            (%null-ptr-p source))
      (warn "Could not find image data at URL ~A." source)) 
    (#_CGContextDrawImage bitmap-context rect image)
    (#_CGContextRelease bitmap-context)
    (#_glPixelStorei #$GL_UNPACK_ROW_LENGTH width)
    (#_glPixelStorei #$GL_UNPACK_ALIGNMENT 1)
    (when (= tex-name 0)
      (rlet ((uid :<GL>uint))
        (#_glGenTextures 1 uid)
        (setf tex-name (%get-unsigned-word uid))))
    (#_glBindTexture #$GL_TEXTURE_RECTANGLE_ARB tex-name)
    (#_glTexParameteri #$GL_TEXTURE_RECTANGLE_ARB #$GL_TEXTURE_MAG_FILTER mag-filter)
    (#_glTexParameteri #$GL_TEXTURE_RECTANGLE_ARB #$GL_TEXTURE_MIN_FILTER min-filter)
    (#_glTexImage2D #$GL_TEXTURE_RECTANGLE_ARB 0 #$GL_RGBA8 width height
                    0 #$GL_BGRA_EXT #$GL_UNSIGNED_INT_8_8_8_8_REV data)
    (#_free data)
    (values tex-name (coerce width 'float) (coerce height 'float))))

(defmethod load-texture ((tex texture))
  (when (glview tex)
    (with-slots (glview source binding width height min-filter mag-filter) tex
      (multiple-value-bind (name w h)
                           (%gl-texture-image-from-source source mag-filter min-filter)
        (setf binding name
              width w
              height h)))))

;;;
;;; Scene Graph Management
;;;

(defclass gl-drawable()
  ((use-display-lists-p :accessor use-display-lists-p :initarg :use-display-lists-p :initform t)
   (dlist :accessor dlist :initarg :dlist :initform nil)
   (needs-updating-p :accessor needs-updating-p :initform nil)))

(defgeneric draw (gl-drawable))

(defmethod draw :around ((object gl-drawable))
  "Note:  This method must be called with a gl context active, or it will crash CCL!"
  (if (not (use-display-lists-p object))
    (call-next-method)
    (with-slots (dlist) object
      (if (needs-updating-p object)
        (progn
          (when dlist
            (#_glDeleteLists dlist 1))
          (setf dlist (#_glGenLists 1))
          (#_glNewList dlist #$GL_COMPILE)
          (call-next-method))
        (#_glCallList dlist)))))